home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / link.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  9KB  |  246 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. ;;; Link a shared library.
  4. ;;; Only create symbols NOT found in other libraries.
  5. (defun link-library (lib-name &key 
  6.                   other-lib-names
  7.                   (predicates-file (tmp-file-name "preds.lisp") p?)
  8.                   (data-file (tmp-file-name "data.c") d?))
  9.   (let ((*pic?* t))
  10.     (unwind-protect
  11.      (let ((*link-start-time* (get-universal-time))
  12.            (library (lookup-library lib-name)))
  13.        (create-library-aux-files
  14.         lib-name other-lib-names predicates-file data-file)
  15.        (ld-shared-library library predicates-file data-file)
  16.        library)
  17.       ;; If caller supplies and aux file name, assume they want to keep it.
  18.       (unless p? (del-derived-files predicates-file))
  19.       (unless d? (del-derived-files data-file)))))
  20.  
  21. (defun create-library-aux-files (lib-name other-lib-names
  22.                     predicates-file data-file)
  23.                     
  24.   (let* ((library (lookup-library lib-name))
  25.      (other-libraries (mapcar #'lookup-initialized-library
  26.                   other-lib-names))
  27.      (symbol-table (clear-symbol-table (library-symbol-table library)))
  28.      (structures (new-structure-table))
  29.      (*const-labels* (make-hash-table :size 5000 :test #'equal)))
  30.     (clrhash (library-procedure-info library))
  31.     (clrhash (library-c-type-info library))
  32.     (setf (library-proclaims library) nil)
  33.     (link-msg "Reading symbol information")
  34.     (multiple-value-bind (lisp-init-thunks symbol-fixups)
  35.     (setup-application-symbols other-libraries symbol-table structures
  36.                    (library-lisp-files library) library)
  37.       (compile-predicates-file
  38.        predicates-file other-libraries symbol-table structures)
  39.       (compile-library-data-file data-file other-libraries
  40.                  symbol-table symbol-fixups
  41.                  (library-init-thunk library)
  42.                  lisp-init-thunks)
  43.       (write-library-info library)
  44.       lib-name)))
  45.     
  46.  
  47. (defun link-executable (files &key
  48.                   output
  49.                   (lib-names *default-libraries*)
  50.                   (dynamic-size 8192)
  51.                   (static-size 512)
  52.                   (main-function 'user::lmain)
  53.                   (predicates-file (tmp-file-name
  54.                         "preds.lisp") p?)
  55.                   (data-file (tmp-file-name "data.c") d?)
  56.                   (foreign-libs '("c" "m" )))
  57.   (unwind-protect
  58.        (let* ((*link-start-time* (get-universal-time))
  59.           (file-list (if (listp files) files (list files)))
  60.           (output (or output (make-pathname
  61.                   :defaults (first file-list)
  62.                   :type nil)))
  63.           (libraries (mapcar #'lookup-initialized-library
  64.                  lib-names))
  65.           (all-libs
  66.            (append (mapcar #'(lambda (l)
  67.                    (string-downcase (library-name l)))
  68.                    libraries)
  69.                foreign-libs)))
  70.      (create-executable-aux-files
  71.       file-list libraries dynamic-size static-size main-function
  72.       predicates-file data-file)
  73.      (ld-executable output file-list predicates-file data-file all-libs)
  74.      output)
  75.     (unless p? (del-derived-files predicates-file))
  76.     (unless d? (del-derived-files data-file))))
  77.  
  78. (defun create-executable-aux-files (files libraries dynamic-size static-size
  79.                       main-function
  80.                       predicates-file data-file)
  81.   (let* ((symbol-table (new-symbol-table))
  82.      (structures (new-structure-table))
  83.      (*const-labels* (make-hash-table :size 5000 :test #'equal)))
  84.     (link-msg "Reading symbol information")
  85.     (multiple-value-bind (lisp-init-thunks symbol-fixups)
  86.     (setup-application-symbols libraries symbol-table structures files)
  87.       (compile-predicates-file
  88.        predicates-file libraries symbol-table structures)
  89.       (compile-executable-data-file  data-file libraries
  90.                      symbol-table symbol-fixups
  91.                      lisp-init-thunks
  92.                      main-function
  93.                      dynamic-size static-size))))
  94.  
  95.  
  96. (defun compile-predicates-file (predicates-file libs symbol-table structures)
  97.   (with-open-file (output predicates-file :direction :output)
  98.     (maphash #'(lambda (name info)
  99.          (declare (ignore name))
  100.          (write (application-structure-predicate info structures)
  101.             :stream output
  102.             :array t)
  103.          (terpri output))
  104.          structures))
  105.   (link-msg "Compiling predicates file")
  106.   (comf predicates-file)
  107.   ;; Add new symbols created in preds file to symbol-table
  108.   (setup-application-symbols
  109.    libs symbol-table structures (list predicates-file)))
  110.  
  111.  
  112. ;;;    lib_init_thunk (c-code)
  113. ;;;      <c code register_symbols for each package in lib>
  114. ;;;      <symbol-fixups>
  115. ;;;      call-each-lib-file-init-thunk
  116. (defun compile-library-data-file (data-file
  117.                   other-libraries
  118.                   symbol-table symbol-fixups
  119.                   thunk-name library-lisp-thunks)
  120.   (link-msg "Writing data file")
  121.   ;; Setup stream for EMIT-DATA
  122.   (with-open-file (*k-stream* data-file :direction :output)
  123.     (emit-symbol-table other-libraries symbol-table)
  124.     (emit-k "~%~A()~%{~%" thunk-name)
  125.     (emit-symbol-table-registration-code symbol-table)
  126.     (emit-k "~{ ~A~% ~}~%" symbol-fixups)
  127.     (dolist (lisp-thunk library-lisp-thunks)
  128.       (emit-k "~A(0);~%" (lisp->c-proc-name lisp-thunk)))
  129.     (emit-k "}~%"))
  130.   (link-msg "Compiling data file")
  131.   (invoke-c-compiler data-file))
  132.  
  133. ;;;   main (c-code)
  134. ;;;     start_initialization(sizes);
  135. ;;;     <c code register_symbols for each package in app>
  136. ;;;     <symbol-fixups>
  137. ;;;     call-each-lib-init-thunk 
  138. ;;;     call-each-app-file-init-thunk  [LISP]
  139. ;;;     (catch (main-func))  [LISP]
  140. (defun compile-executable-data-file (data-file
  141.                      libraries
  142.                      symbol-table symbol-fixups
  143.                      application-lisp-thunks
  144.                      main-function
  145.                      dynamic-size static-size)
  146.   (link-msg "Writing data file")
  147.   ;; Setup stream for EMIT-DATA
  148.   (with-open-file (*k-stream* data-file :direction :output)
  149.     (emit-symbol-table libraries symbol-table)
  150.     (emit-k "main(argc,argv) int argc; char *argv[]; {~%")
  151.     (emit-k "start_initialization(argc,argv,~D,~D);~%"
  152.         dynamic-size static-size)
  153.     (emit-symbol-table-registration-code symbol-table)
  154.     (emit-k "~{ ~A~% ~}~%" symbol-fixups)
  155.     (dolist (lib libraries)
  156.       (emit-k "~A();~%" (library-init-thunk lib)))
  157.     (dolist (lisp-thunk application-lisp-thunks)
  158.       (emit-k "~A(0);~%" (lisp->c-proc-name lisp-thunk)))
  159.     (emit-k "p_lsp_START_2DAPPLICATION(1,LREF(~A));~%"
  160.         (lisp->c-symbol-name main-function))
  161.     (emit-k "}~%"))
  162.   (link-msg "Compiling data file")
  163.   (invoke-c-compiler data-file))
  164.  
  165. (defun ld-shared-library (library predicates-file data-file)
  166.   (link-msg "Linking shared library")
  167.   (shell (format nil "ld -o ~A ~{ ~A ~} ~A ~A~%"
  168.          (library-unix-name library)
  169.          (library-all-object-files library)
  170.          (binary-pathname predicates-file)
  171.          (binary-pathname data-file))))
  172.  
  173. (defun ld-executable (output-file files preds-file data-file unix-libs)
  174.   (invoke-linker
  175.    (format nil
  176.        "~A -o ~A ~A ~A ~{~A ~} -L~A/lib ~{-l~A ~}"
  177.        (if *profile?* "-p " "")
  178.        (namestring output-file)
  179.        (namestring (merge-pathnames ".o" preds-file))
  180.        (namestring (merge-pathnames ".o" data-file))
  181.        (mapcar #'binary-pathname files)
  182.        *root-directory*
  183.        unix-libs))
  184.   (link-msg "done")
  185.   output-file)
  186.  
  187. (defun invoke-c-compiler (file &optional
  188.                    (output (merge-pathnames ".o" file)))
  189.   (let ((status
  190.      (funcall
  191.       #'shell
  192.       (format nil "~A  -c -I~A/include -o ~A ~A"
  193.           (basic-cc-string)
  194.           (namestring *root-directory*)
  195.           (namestring output)
  196.           (namestring file)))))
  197.     (unless (successful-status? status)
  198.       (error "Failed to compile file: ~S, status: ~D" file status))
  199.     status))
  200.  
  201. (defun basic-cc-string ()
  202.   (let ((c-compiler (machine-c-compiler *target-machine*)))
  203.     (concatenate 'string
  204.          (c-compiler-command c-compiler)
  205.          " "
  206.          (if (config-cc-debug-info? *config*)
  207.              (c-compiler-debug-switch c-compiler)
  208.              nil)
  209.          " "
  210.          (if (or (not (config-cc-debug-info? *config*))
  211.              (c-compiler-debug-optimized? c-compiler))
  212.              (svref (c-compiler-optimizer-switches c-compiler)
  213.                 (config-cc-optimizer-level *config*))
  214.              "")
  215.          " "
  216.          (if *pic?*
  217.              (c-compiler-position-independent-code-switch
  218.               (machine-c-compiler *target-machine*))
  219.              ""))))
  220.  
  221. (defun invoke-linker (cmd)
  222.   (let ((status
  223.      (funcall #'shell
  224.           (concatenate 'string
  225.                    (machine-linker-command *target-machine*)
  226.                    " " cmd " "
  227.                    (machine-link-libraries *target-machine*)))))
  228.     (unless (successful-status? status)
  229.       (error "Failed to link: ~S, status: ~D" cmd status))
  230.     status))
  231.  
  232. (defun successful-status? (s)
  233.   (= s 0))
  234.  
  235. (defun elapsed-link-time ()
  236.   (- (get-universal-time) *link-start-time*))
  237.  
  238. (defun link-msg (msg)
  239.   (format t "~D seconds: ~A~%" (elapsed-link-time) msg))
  240.  
  241. (defun c-pathname (name)
  242.   (merge-pathnames ".c" name))
  243.  
  244. (defun binary-pathname (name)
  245.    (merge-pathnames ".o" name))
  246.